home *** CD-ROM | disk | FTP | other *** search
- ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; The data in this file contains enhancments. ;;;;;
- ;;; ;;;;;
- ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
- ;;; All rights reserved ;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (in-package "MAXIMA")
- (macsyma-module ezgcd)
-
- (DECLARE-TOP(SPECIAL VARLIST GENVAR LCPROD SVALS SVARS OLDSVARS OLDSVALS
- VALFLAG $GCD PL0 D0 DEGD0 SUBVAR SUBVAL VAR
- MANY* TEMPPRIME OVARLIST VALIST MODULUS KLIM
- ZL *PRIME PLIM NN* NE NN*-1 BLIST1 DLP *ALPHA
- EZ1SKIP SVALSL NSVALS ERRRJFFLAG $ALGEBRAIC
- LC1 OLDLC DF1 DF2 RES LIMK *AB* *ALPHA
- *SHARPA *SHARPB FACT1 FACT2 HMODULUS $RATFAC)
- (*EXPR ITH)
- (GENPREFIX EZG))
-
- (LOAD-MACSYMA-MACROS RATMAC)
-
- (DEFUN EZGCD2 (F G) (PROG (ALLVARS)
- (SETQ ALLVARS (UNION* (LISTOVARS F) (LISTOVARS G)))
- (COND ((GREATERP 2 (LENGTH ALLVARS))
- (SETQ ALLVARS (NEWGCD F G MODULUS))
- (COND ((CDR ALLVARS) (RETURN ALLVARS))
- (T (RETURN (LIST (SETQ ALLVARS (CAR ALLVARS))
- (PQUOTIENT F ALLVARS)
- (PQUOTIENT G ALLVARS)))))))
- (SETQ ALLVARS (SORT ALLVARS 'POINTERGP))
- (RETURN (EZGCD (LIST F G) ALLVARS MODULUS))
- ))
-
- (DEFUN NEWGCDCALL (P Q) (CAR (NEWGCD P Q MODULUS)))
-
- (DEFUN GCDL (PL)
- (DO ((D (CAR PL) (PGCD D (CAR L)))
- (L (CDR PL) (CDR L)))
- ((OR (NULL L) (EQUAL D 1)) D)))
-
- (DEFUN NEWGCDL (PL)
- (LET (($GCD '$MOD))
- (GCDL PL)))
-
- (DEFUN OLDGCDL (ELT PL)
- (LET (($GCD '$RED))
- (GCDL (CONS ELT PL))))
-
- (DEFUN OLDGCDCALL (PFL)
- (LET ((A (OLDGCDL (CAR PFL) (CDR PFL))))
- (CONS A (MAPCAR (FUNCTION (LAMBDA (H) (PQUOTIENT H A))) PFL))))
-
- (DEFUN NON0RAND (MODULUS)
- (DO ((R)) ((NOT (ZEROP (SETQ R (CMOD (RANDOM 1000))))) R)))
-
- (DECLARE-TOP(SPECIAL TEMPPRIME))
-
- (DEFUN GETGOODVALS (VARL LCP)
- (MAPCAR #'(LAMBDA (V) (DO ((VAL 0 (NON0RAND TEMPPRIME)) (TEMP))
- ((NOT (PZEROP (SETQ TEMP (PCSUBSTY VAL V LCP))))
- (SETQ LCP TEMP) VAL)))
- VARL))
-
- (DEFUN EVMAP (VALS PL)
- (PROG (PL0 D0)
- (COND ((EQUAL NSVALS (LENGTH SVALSL)) (RETURN NIL)))
- (COND (VALFLAG (GO NEWVALS)))
- (SETQ VALS (GETGOODVALS SVARS LCPROD))
- AGAIN(COND ((zl-MEMBER VALS SVALSL)
- (SETQ VALS (RAND (LENGTH SVARS) TEMPPRIME))
- (GO AGAIN)))
- (SETQ VALFLAG T SVALSL (CONS VALS SVALSL))
- (GO END)
- NEWVALS
- (SETQ PL0 (RAND (LENGTH SVARS) TEMPPRIME))
- (COND ((zl-MEMBER PL0 SVALSL) (GO NEWVALS))
- (T (SETQ VALS PL0 SVALSL (CONS VALS SVALSL))))
- (COND ((EQUAL 0. (PCSUB LCPROD VALS SVARS))
- (COND ((EQUAL NSVALS (LENGTH SVALSL))
- (RETURN NIL))
- (T (GO NEWVALS)))))
- ; END (GETD0 PL(SETQ VALS(SUBST 1. 0. VALS))) WHAT WAS SUBST FOR?
- END (GETD0 PL VALS)
- (RETURN (LIST VALS PL0 D0))))
-
- (DEFUN DEGODR (A B) (COND ((NUMBERP A) NIL)
- ((NUMBERP B) T)
- (T (GREATERP (CADR A) (CADR B)))))
-
- (DEFUN EVTILDEGLESS (PL)
- (PROG (EVOUT NPL0 ND0 NDEG)
- AGAIN(SETQ EVOUT (EVMAP SVALS PL))
- (COND (EVOUT (SETQ NPL0 (CADR EVOUT) ND0 (CADDR EVOUT)))
- (T (RETURN NIL)))
- (COND ((NUMBERP ND0) (SETQ NDEG 0.)) (T (SETQ NDEG (CADR ND0))))
- (COND ((OR (EQUAL DEGD0 NDEG) (GREATERP NDEG DEGD0)) (GO AGAIN)))
- (RETURN (SETQ DEGD0 NDEG PL0 NPL0 D0 ND0 SVALS (CAR EVOUT)))))
-
- (DEFUN PTIMESMERGE (PL1 PL2)
- (COND (PL1 (CONS (PTIMES (CAR PL1) (CAR PL2))
- (PTIMESMERGE (CDR PL1) (CDR PL2))))
- (T NIL)))
-
- ;(DEFUN RESTORELCZ (P INVLC LC)
- ; (LET ((VAR) (DEG))
- ; (COND ((EQUAL 1 INVLC)
- ; (SETQ P (PMOD (OLDREP P)))
- ; (SETQ VAR (CAR P)))
- ; (T (SETQ VAR (CAR P))
- ; (SETQ DEG (CADR P))
- ; (SETQ P (PTIMES INVLC (PSIMP VAR (CDDDR P))))
- ; (SETQ P (PPLUS (LIST VAR DEG LC)
- ; (PMOD (OLDREP (DROPTERMS P)))))))
- ; (LET ((MODULUS))
- ; (CADR (FASTCONT P)))))
-
- ;(DEFUN RPLALC (POLY NEWLC)
- ; (APPEND (LIST (CAR POLY) (CADR POLY) NEWLC) (CDDDR POLY)))
-
-
- ;(DEFUN EZ1 (POLY FACT1 FACT2)
- ; (PROG (RES HSTEPS STEPS KTERM A B C D *AB* M DF1 DF2 DLR STEP *SHARPA *SHARPB)
- ; (LET ((MODULUS) (HMODULUS))
- ; (SETQMODULUS *PRIME)
- ; (SETQ *SHARPB (FACT20 FACT1 FACT2 LIMK)))
- ; (SETQ *SHARPA (CAR *SHARPB))
- ; (SETQ *SHARPB (CADR *SHARPB))
- ; (SETQ *AB* (LIST (LIST 0 *SHARPA *SHARPB)))
- ; (SETQ STEPS (APPLY 'MAX (MAPCAR (FUNCTION MULTIDEG) (CDR (ODDELM POLY)))))
- ; (SETQ HSTEPS (QUOTIENT STEPS 2.))
- ; (SETQ STEP 0)
- ; (SETQ DF1 (RPLALC FACT1 (PMOD (NEWREP LC1))))
- ; (SETQ DF2 (RPLALC FACT2 (PMOD (NEWREP OLDLC))))
- ; (SETQ RES (PDIFFERENCE (PTIMES DF1 DF2) (PMOD POLY)))
- ; (SETQ POLY NIL)
- ; LOOP (COND ((EQUAL RES 0) (GO OUT)))
- ; BK (SETQ STEP (ADD1 STEP))
- ; (COND ((GREATERP STEP STEPS) (GO OUT)))
- ; (COND ((EQ (CAR RES) VAR)(SETQ C (CDR RES)))
- ; (T (SETQ C (LIST 0 RES))))
- ; (SETQ A 0 B 0)
- ;NEXTM (COND ((NULL C)(Z2 A B STEP HSTEPS)(GO LOOP)))
- ; (SETQ M (CAR C))
- ; (SETQ DLR (CADR C))
- ; (SETQ C (CDDR C))
- ; (SETQ KTERM (KTERMS DLR STEP))
- ; (SETQ DLR NIL)
- ; (COND ((EQUAL 0 KTERM) (GO NEXTM)))
- ; (SETQ D (OBTAINABM M))
- ; (SETQ B (PPLUS B (PTIMES (CAR D) KTERM)))
- ; (SETQ A (PPLUS A (PTIMES (CADR D) KTERM)))
- ; (SETQ KTERM NIL)
- ; (GO NEXTM)
- ; OUT (RETURN (LIST DF1 DF2))))
-
- (DEFUN EZ1CALL (BUILDER FACTRS LC1 VALIST OVARLIST)
- (PROG (*PRIME PLIM NN* NE NN*-1 ZL ZFACTR OLDLC LCD0
- BLIST1 DLP LIMK GENVAR SUBVAR SUBVAL MULT)
- (SETQ OLDLC (CADDR BUILDER))
- (COND ((NOT (EQUAL 1 LC1))
- (SETQ BUILDER (PTIMES BUILDER LC1))))
- (SETQ GENVAR (APPEND OVARLIST (LIST (CAR BUILDER))))
- (COND (MODULUS
- (SETQ *PRIME MODULUS PLIM MODULUS LIMK -1)
- (GO MOD))
- (T (SETQ *PRIME (MAX (NORM BUILDER)
- (MAXCOEFFICIENT (CAR FACTRS))
- (MAXCOEFFICIENT (CADR FACTRS))))))
- (COND ((GREATERP *PRIME *ALPHA)
- (PROG (NEWMODULUS)
- (SETQ NEWMODULUS (TIMES *ALPHA *ALPHA)
- LIMK 0)
- AGAIN(COND ((GREATERP NEWMODULUS *PRIME)
- (SETQ *PRIME *ALPHA PLIM NEWMODULUS))
- (T (SETQ LIMK (ADD1 LIMK) NEWMODULUS (TIMES NEWMODULUS NEWMODULUS))
- (GO AGAIN)))))
- (T (SETQ LIMK -1 *PRIME *ALPHA PLIM *ALPHA)))
- MOD (SETQ NN* (ADD1 (SETQ NE (SETQ NN*-1 (LENGTH OVARLIST)))))
- (SETQ ZL (COMPLETEVECTOR NIL 1 NN* 0))
- (FIXVL VALIST OVARLIST)
- (COND ((EQUAL 1 LC1)
- (SETQ MODULUS PLIM BUILDER (NEWREP BUILDER))
- (SETQ DLP #+NIL (sloop for x in (cdr (oddelm builder))
- maximize (multideg x))
- #-NIL (APPLY 'MAX
- (MAPCAR (FUNCTION MULTIDEG)
- (CDR (ODDELM BUILDER)))))
- (SETQ ZFACTR (Z1 BUILDER (CAR FACTRS)(CADR FACTRS)))
- (SETQ ZFACTR (RESTORELC ZFACTR (CADDR BUILDER)))
- (RETURN (OLDREP(CADR ZFACTR)))))
- (SETQ MODULUS PLIM LCD0 (CADDAR FACTRS))
- (SETQ MULT (CTIMES (PCSUB LC1 SVALS SVARS)
- (CRECIP LCD0)))
- (SETQ FACTRS (LIST (PTIMES MULT (CAR FACTRS))
- (PTIMES LCD0 (CADR FACTRS))))
- (SETQ BUILDER (NEWREP BUILDER))
- (SETQ DLP #+NIL (sloop for x in (cdr (oddelm builder))
- maximize (multideg x))
- #-NIL (APPLY 'MAX (MAPCAR (FUNCTION MULTIDEG)
- (CDR (ODDELM BUILDER)))))
- (SETQ ZFACTR (Z1 BUILDER (CAR FACTRS) (CADR FACTRS)))
- (SETQ ZFACTR (PMOD (OLDREP (CAR ZFACTR))))
- (RETURN (CADR ((LAMBDA (MODULUS) (FASTCONT ZFACTR)) NIL)))))
-
- (DEFUN GETD0 (TPL TVALS) (PROG (C)
- (SETQ D0 (PCSUB (CAR TPL) TVALS SVARS)
- PL0 (LIST D0) TPL (CDR TPL))
- LOOP (COND ((NULL TPL) (RETURN D0)))
- (SETQ C (PCSUB (CAR TPL) TVALS SVARS)
- D0 (NEWGCDCALL D0 C))
- (COND ((NUMBERP D0) (RETURN (SETQ D0 1))))
- (SETQ PL0 (APPEND PL0 (LIST C)) TPL (CDR TPL))
- (GO LOOP)))
-
- (DEFUN NUMBERINLISTP (L)
- (DO ((L L (CDR L))) ((NULL L))
- (AND (NUMBERP (CAR L)) (RETURN (CAR L)))))
-
- (DEFUN EZGCD (PFL VL MODULUS)
- (PROG (SVARS SVALS VALFLAG TEMPPRIME PFCONTL CONTGCD CONTCOFACTL
- PL NSVARS NSVALS SVALSL LCPROD GCDLCS LCPL EVMAPOUT
- PL0 D0 D DEGD0 DEGD0N D0N PL0N TEMP TRYAGAIN COFACT0
- PCOFACTL ITH BUILDER VAR TERMCONT TCONTL $ALGEBRAIC)
- (COND ((SETQ TEMP (NUMBERINLISTP PFL))
- (COND ((OR (zl-MEMBER 1 PFL)(zl-MEMBER -1 PFL))
- (RETURN (CONS 1 PFL))))
- (SETQ TEMP (OLDGCDL TEMP (zl-REMOVE TEMP PFL))
- PL (MAPCAR (FUNCTION (LAMBDA(H) (PQUOTIENT H TEMP))) PFL))
- (RETURN (CONS TEMP PL))))
- (SETQ SVARS (CDR VL) VAR (CAR VL))
- (COND (SVARS (SETQ MANY* T))
- (T (RETURN (CONS (SETQ D (NEWGCDL PFL))
- (MAPCAR (FUNCTION (LAMBDA(H) (PQUOTIENT H D))) PFL)))))
- (COND (MODULUS (SETQ TEMPPRIME MODULUS))
- (T (SETQ TEMPPRIME 13.)))
- (SETQ TCONTL (MAPCAR (FUNCTION PTERMCONT) PFL)
- PFL (MAPCAR (FUNCTION CADR) TCONTL)
- TCONTL (MAPCAR (FUNCTION CAR) TCONTL))
- (SETQ TERMCONT (OLDGCDCALL TCONTL)
- TCONTL (CDR TERMCONT)
- TERMCONT (CAR TERMCONT))
- (COND ((SETQ TEMP (NUMBERINLISTP PFL))
- (SETQ D (OLDGCDL TEMP (zl-REMOVE TEMP PFL))
- PCOFACTL
- (MAPCAR (FUNCTION (LAMBDA(H) (PQUOTIENT H D))) PFL))
- (SETQ CONTGCD TERMCONT CONTCOFACTL TCONTL)
- (GO OUT)))
- (SETQ PFCONTL
- (MAPCAR (FUNCTION (LAMBDA(H)
- (COND ((EQ VAR (CAR H)) (FASTCONT H))
- (T (LIST H 1)))))
- PFL))
- (SETQ PFL
- (MAPCAR (FUNCTION CADR) PFCONTL)
- PFCONTL
- (MAPCAR (FUNCTION CAR) PFCONTL))
- (SETQ CONTGCD (EZGCD PFCONTL SVARS MODULUS) PFCONTL NIL
- CONTCOFACTL (PTIMESMERGE TCONTL (CDR CONTGCD))
- CONTGCD (PTIMES TERMCONT (CAR CONTGCD)))
- (COND ((NUMBERINLISTP PFL)
- (SETQ D 1. PCOFACTL PFL)(GO OUT)))
- (SETQ TEMP (LISTOVARSL PFL))
- (COND ((SETQ TEMP (INTERSECT SVARS TEMP)) NIL)
- (T (SETQ D (NEWGCDL PFL)) (GO END)))
- (SETQ PL (BBSORT PFL (QUOTE DEGODR)))
- (SETQ NSVARS (LENGTH SVARS))
- (DO ((I NSVARS (SUB1 I))) ((ZEROP I)) (SETQ SVALS (CONS 0. SVALS)))
- (SETQ LCPROD 1 SVALSL (LIST SVALS)
- NSVALS (EXPT TEMPPRIME (LENGTH SVARS)))
- (DO ((L
- (MAPCAR (FUNCTION CADDR) PL)
- (CDR L)))
- ((NULL L))
- (SETQ LCPROD (PTIMES LCPROD (CAR L))))
- (COND ((EQUAL 0. (PCSUB LCPROD SVALS SVARS))
- (SETQ EVMAPOUT (EVMAP SVALS PL))
- (COND (EVMAPOUT (SETQ SVALS (CAR EVMAPOUT)
- PL0 (CADR EVMAPOUT)
- D0 (CADDR EVMAPOUT)))
- (T (DESETQ (D . PCOFACTL) (OLDGCDCALL PFL))
- (GO OUT))))
- (T (SETQ VALFLAG T) (GETD0 PL SVALS)))
- (COND ((NUMBERP D0) (SETQ DEGD0 0))
- (T (SETQ DEGD0 (CADR D0))))
- TESTD0
- (COND ((EQUAL 1. D0) (SETQ D 1.)
- (SETQ D 1. PCOFACTL PFL) (GO OUT)))
- (COND (DEGD0N (GO TESTCOFACT)))
- ANOTHERSVALS
- (SETQ EVMAPOUT (EVMAP SVALS PL))
- (COND (EVMAPOUT (SETQ PL0N (CADR EVMAPOUT)
- D0N (CADDR EVMAPOUT)
- EVMAPOUT (CAR EVMAPOUT)))
- (T (DESETQ (D . PCOFACTL) (OLDGCDCALL PFL))
- (GO OUT)))
- (COND ((NUMBERP D0N) (SETQ DEGD0N 0.))
- (T (SETQ DEGD0N (CADR D0N))))
- (COND ((GREATERP DEGD0 DEGD0N)
- (SETQ DEGD0 DEGD0N PL0 PL0N D0 D0N SVALS EVMAPOUT)
- (GO ANOTHERSVALS)))
- (COND ((EQUAL DEGD0 DEGD0N) (GO TESTD0)) (T (GO ANOTHERSVALS)))
- TESTCOFACT
- (COND ((EQUAL DEGD0 (CADAR PL0)) NIL) (T (GO TESTGCD)))
- (SETQ D (CAR PL) TEMP PFL PCOFACTL NIL)
- LOOP (COND (TEMP (SETQ D0N (EZTESTDIVIDE (CAR TEMP) D)))
- (T (SETQ EZ1SKIP T) (GO OUT)))
- (COND (D0N (SETQ PCOFACTL (APPEND PCOFACTL (LIST D0N)))
- (SETQ TEMP (CDR TEMP)) (GO LOOP))
- (T (COND ((EVTILDEGLESS PL)
- (SETQ DEGD0N NIL) (GO TESTD0))
- (T (DESETQ (D . PCOFACTL) (OLDGCDCALL PFL))
- (GO OUT)))))
- TESTGCD
- (SETQ ITH 1. TEMP PL0)
- NEXT (COND (TEMP NIL)
- (T (COND (TRYAGAIN (SETQ D (NONSQFRCASE PFL VL)
- PCOFACTL (CDR D)
- D (CAR D))
- (GO OUT))
- (T (SETQ DEGD0 DEGD0N PL0 PL0N D0 D0N
- DEGD0N NIL PL0N NIL D0N NIL
- SVALS EVMAPOUT TRYAGAIN T)
- (GO TESTGCD)))))
- (SETQ COFACT0 (PQUOTIENT (CAR TEMP) D0))
- (COND ((NUMBERP (NEWGCDCALL D0 COFACT0))
- (SETQ BUILDER (ITH PL ITH))
- (COND ((INTERSECT (LISTOVARS BUILDER) SVARS)
- (GO CALLEZ1)))))
- (SETQ TEMP (CDR TEMP) ITH (ADD1 ITH)) (GO NEXT)
- CALLEZ1
- (SETQ LCPL (MAPCAR (FUNCTION CADDR) PL)
- GCDLCS (CAR (EZGCD LCPL SVARS MODULUS))
- LCPL NIL)
- (SETQ D (EZ1CALL BUILDER
- (LIST D0 COFACT0) GCDLCS
- (REVERSE SVALS)
- (REVERSE SVARS)))
- (SETQ MODULUS NIL)
- END (SETQ PCOFACTL NIL TEMP PFL)
- (COND ((PMINUSP D) (SETQ D (PMINUS D))))
- LOOP1(COND (TEMP (SETQ COFACT0 (EZTESTDIVIDE (CAR TEMP) D)))
- (T (SETQ EZ1SKIP NIL) (GO OUT)))
- (COND (COFACT0 (SETQ PCOFACTL (APPEND PCOFACTL (LIST COFACT0)))
- (SETQ TEMP (CDR TEMP)) (GO LOOP1))
- (T (COND ((EVTILDEGLESS PL)
- (SETQ DEGD0N NIL) (GO TESTD0))
- (T (DESETQ (D . PCOFACTL) (OLDGCDCALL PFL))
- (GO OUT)))))
- OUT (SETQ OLDSVARS SVARS OLDSVALS SVALS)
- (RETURN (CONS (PTIMES CONTGCD D)
- (PTIMESMERGE CONTCOFACTL PCOFACTL)))))
-
- (DEFUN LISTOVARSL (PLIST) (PROG (ALLVARSL ALLVARS)
- (SETQ ALLVARSL (MAPCAR (FUNCTION LISTOVARS) PLIST))
- (SETQ ALLVARS (CAR ALLVARSL))
- (DO ((L (CDR ALLVARSL) (CDR L))) ((NULL L))
- (SETQ ALLVARS (UNION* ALLVARS (CAR L))))
- (RETURN ALLVARS)))
-
- (DEFMFUN $EZGCD NARGS
- (PROG (PFL ALLVARS PRESULT FLAG genvar DENOM PFL2)
- ;need if genvar doesn't shrink
- (IF (= NARGS 0) (WNA-ERR '$EZGCD))
- (DO ((I NARGS (f1- I))) ((= I 0)) (IF ($RATP (ARG I)) (RETURN (SETQ FLAG T))))
- (SETQ PFL (MAPCAR #'(LAMBDA (H) (CDR (RATF H))) (LISTIFY NARGS)))
- (SETQ PFL2 (LIST 1))
- (DO ((LCM (CDAR PFL))
- (L (CDR PFL) (CDR L))
- (COF1) (COF2))
- ((NULL L) (SETQ DENOM LCM))
- (DESETQ (LCM COF1 COF2) (PLCMCOFACTS LCM (CDAR L)))
- (OR (EQUAL COF1 1)
- (MAPCAR #'(LAMBDA (X) (PTIMES X COF1)) PFL2))
- (PUSH COF2 PFL2))
- (SETQ PFL (MAPCAR #'CAR PFL))
- (SETQ ALLVARS (SORT (LISTOVARSL PFL) #'POINTERGP))
- (SETQ PRESULT
- (COND ($RATFAC ((LAMBDA ($GCD) (FACMGCD PFL)) '$EZ))
- (T (EZGCD PFL ALLVARS MODULUS))))
- (SETQ PRESULT (CONS (CONS (CAR PRESULT) DENOM)
- (COND ((EQUAL DENOM 1) (CDR PRESULT))
- (T (MAPCAR #'PTIMES (CDR PRESULT) PFL2)))))
- (SETQ PRESULT (CONS '(MLIST)
- (CONS (RDIS* (CAR PRESULT))
- (MAPCAR #'PDIS* (CDR PRESULT)))))
- (RETURN (IF FLAG PRESULT ($TOTALDISREP PRESULT)))))
-
- (DEFUN INSRT (NTH ELT L)
- (COND ((EQUAL NTH 1) (CONS ELT L))
- (T (CONS (CAR L) (INSRT (f1- NTH) ELT (CDR L))))))
-
- (DEFUN NONSQFRCASE(PL VL)
- (PROG (D F PTR)
- (DO ((DL PL (CDR DL))
- (PT 1 (f1+ PT)))
- ((INTERSECT (CDR VL) (LISTOVARS (CAR DL)))
- (SETQ F (CAR DL) PTR PT)))
- (SETQ D (EZGCD (LIST F (PDERIVATIVE F (CAR F))) VL MODULUS)
- PL (EZGCD (CONS (CADR D) (zl-REMOVE F PL)) VL MODULUS)
- PL (CONS (CAR PL) (CONS (CAR D) (CDDR PL)))
- D (CAR PL))
- LOOP (SETQ PL (EZGCD PL VL MODULUS))
- (COND ((EQUAL 1 (CAR PL))
- (RETURN (CONS D (INSRT PTR (PQUOTIENT F D) (CDDDR PL))))))
- (SETQ D (PTIMES (CAR PL) D)
- PL (CONS (CAR PL) (CDDR PL)))
- (GO LOOP)))
-
- (DEFUN EZTESTDIVIDE (X Y)
- (LET ((ERRRJFFLAG T))
- (COND ((OR (PCOEFP X) (PCOEFP Y)
- (CATCH 'RATERR (PQUOTIENT (CAR (LAST X)) (CAR (LAST Y)))))
- (CATCH 'RATERR (PQUOTIENT X Y))))))
-
- (DEFUN NOTERMS (P)
- (COND ((PCOEFP P) 1)
- (T (DO ((NT (NOTERMS (CADDR P)) (f+ NT (NOTERMS (CADR P))))
- (P (CDDDR P) (CDDR P)))
- ((NULL P) NT)))))
-
- (DEFUN FASTCONT (P)
- (PROG (OLDGENVAR VAR TPPL TCONTL TCONT COEFVARL TEMP SMALL1 SMALL2 ANS MINUS?)
- (COND ((UNIVAR (CDR P)) (RETURN (OLDCONTENT P)))
- (T (SETQ OLDGENVAR GENVAR)
- (SETQ VAR (CAR P))
- (SETQ GENVAR (zl-REMOVE VAR (INTERSECT (CDR GENVAR) (LISTOVARS P))))))
- (COND ((PMINUSP P) (SETQ P (PMINUS P) MINUS? T)))
- (SETQ TPPL (ODDELM (CDDR P)))
- (COND ((NULL (CDR TPPL))
- (SETQ TCONT 1)
- (SETQ ANS (CAR TPPL))
- (GO OUT)))
- (SETQ TCONTL (MAPCAR (FUNCTION PMINDEGVEC) TPPL))
- (SETQ TPPL (MAPCAR (FUNCTION (LAMBDA(X Y) (PQUOTIENT X (DEGVECDISREP Y))))
- TPPL TCONTL))
- (SETQ TCONT (CAR TCONTL))
- (DO ((L (CDR TCONTL) (CDR L))) ((NULL L))
- (SETQ TCONT (MAPCAR (FUNCTION (LAMBDA (X Y) (MIN X Y)))
- TCONT (CAR L))))
- (SETQ TCONTL NIL)
- (SETQ TCONT (DEGVECDISREP TCONT))
- (SETQ GENVAR OLDGENVAR)
- (COND ((SETQ TEMP (NUMBERINLISTP TPPL))
- (COND ((OR (zl-MEMBER 1 TPPL)(zl-MEMBER -1 TPPL))
- (SETQ ANS 1))
- (T (SETQ ANS (OLDGCDL TEMP (zl-DELETE TEMP TPPL)))))
- (GO OUT)))
- (COND ((GREATERP 4 (LENGTH TPPL))
- (SETQ TPPL (BBSORT TPPL
- (FUNCTION (LAMBDA(A B) (GREATERP (LENGTH A) (LENGTH B))))))
- (GO SKIP)))
- (SETQ COEFVARL (MAPCAR (FUNCTION LISTOVARS) TPPL))
- (SETQ TEMP (CAR COEFVARL))
- (SETQ COEFVARL (CDR COEFVARL))
- LOOP (COND ((NULL COEFVARL) NIL)
- (T (COND ((NULL (SETQ TEMP (INTERSECT TEMP (CAR COEFVARL))))
- (SETQ ANS 1) (GO OUT))
- (T (SETQ COEFVARL (CDR COEFVARL)) (GO LOOP)))))
- (SETQ TEMP (MAPCAR (FUNCTION NOTERMS) TPPL))
- (SETQ TPPL (MAPCAR (FUNCTION (LAMBDA (X Y) (LIST X Y)))
- TEMP TPPL))
- (SETQ TPPL (BBSORT TPPL (QUOTE (LAMBDA(X Y) (GREATERP (CAR X) (CAR Y))))))
- (SETQ TPPL (MAPCAR (FUNCTION CADR) TPPL))
- SKIP (SETQ SMALL1 (CAR TPPL))
- (SETQ SMALL2 (CADR TPPL))
- (SETQ ANS (PGCD SMALL1 SMALL2))
- (COND ((EQUAL 1 ANS) (GO OUT))
- ((EQUAL -1 ANS) (SETQ ANS 1) (GO OUT)))
- (COND ((CDDR TPPL) (SETQ ANS (CONS ANS (CDDR TPPL))))
- (T (GO OUT)))
- (SETQ TEMP (SORT (LISTOVARSL ANS) (FUNCTION POINTERGP)))
- (SETQ ANS (CAR (EZGCD ANS TEMP MODULUS)))
- OUT (SETQ TCONT (PTIMES TCONT ANS))
- (SETQ P (PQUOTIENT P TCONT))
- (COND (MINUS? (SETQ TCONT (PMINUS TCONT))))
- (RETURN (LIST TCONT P))))
-
- #-NIL
- (DECLARE-TOP(UNSPECIAL LCPROD SVALS SVARS OLDSVARS OLDSVALS
- VALFLAG PL0 D0 DEGD0 SUBVAR SUBVAL VAR
- MANY* TEMPPRIME OVARLIST VALIST KLIM
- ZL *PRIME PLIM NN* NE NN*-1 BLIST1 DLP
- EZ1SKIP SVALSL NSVALS
- LC1 OLDLC DF1 DF2 RES LIMK *AB*
- *SHARPA *SHARPB FACT1 FACT2))
-